perm filename EEXTRA.PAS[EAL,HE] blob
sn#706596 filedate 1983-04-12 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00009 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (* makeOuterBlock *)
C00004 00003 (* reFormatStmnt *)
C00007 00004 (* Aux routines: readPPLine & readLine *)
C00013 00005 (* aux function for motion clauses: thenCode *)
C00016 00006 (* waitParse *)
C00018 00007 (* armMagicParse *)
C00022 00008 (* addStmnt: more aux routines: descend,elseTest,restoreCursor,setUpNewStmnt,viaOk *)
C00029 00009 (* edit: another aux routine: doAtCmd *)
C00033 ENDMK
C⊗;
(* makeOuterBlock *)
(* makeOuterBlock called by:
eaux3a - procedure readProg;
emain1 - procedure editInit;
Calls to:
appendEnd (1B)
setUpStmnt (eaux3a)
XX *)
procedure makeOuterBlock; (* Make initial BEGIN-END block *)
begin
dprog := newStatement;
with dprog↑ do
begin
stype := progtype;
pcode := newStatement;
with pcode↑ do
begin
stype := blocktype;
blkid := nil;
level := 1;
numvars := 0;
variables := nil;
bparent := nil;
end;
appendEnd(pcode,pcode);
with pcode↑ do bcode := next;
errors := 0;
appendEnd(dprog,pcode);
end;
setUpStmnt;
end;
(* reFormatStmnt *)
(* reFormatStmnt called by:
eedit3 - procedure eEdit3; (editStmnt)
epar3b - function plistParse;
doAtCmd;
Calls to:
putStmnt insertLines deleteLines (level 2)
XX *)
procedure reFormatStmnt(st: statementp; indent,ocur: integer);
var i,j: integer;
begin
with st↑ do
begin
curLine := 1;
setUp := true;
setCursor := false;
j := nlines; (* how long were we *)
putStmnt(st,indent,99); (* possibly reformat us *)
setUp := false;
if j <> nlines then
begin (* if necessary correct for any change in nlines *)
if j < nlines then insertLines(ocur,nlines-j,1) (* fix up screen *)
else if j > nlines then deleteLines(ocur,j-nlines,1);
end;
firstLine := cursorStack[cursor].cline;
lastLine := firstLine + nlines - 1;
end;
if firstline < topDLine then firstLine := topDline;
if botDline < lastLine then
if botDline > topDline + firstDline + dispHeight - 2 then
lastLine := botDline (* it's definitely off screen *)
else botDline := lastLine; (* should be ok.... *)
for i := firstLine - topDline + 1 to lastLine - topDline + 1 do
begin (* flush old lines before redrawing stmnt *)
relLine(lines[i]);
lines[i] := nil;
end;
setCursor := true; (* let putStmnt figure right fieldnum *)
curLine := 0;
putStmnt(dProg,0,99); (* redraw statement *)
setCursor := false;
end;
(* Aux routines: readPPLine & readLine *)
(* XX readPPLine is called by:
readLine (below)
emain5 - procedure eGetCommand; (edit)
Calls to:
exprEditor(1) out1Line(1) *)
(* XX readLine is called from:
etoken - getToken
eaux3a - procedure readProg;
rdLine;
Calls to: readPPLine *)
procedure readPPLine(off: integer); external;
procedure readPPLine;
var ch: ascii; i,j: integer;
begin
if ppOffset >= ppSize then
begin
ch := listing[1];
ppGlitch; (* so line has room to overflow *)
ppOffset := ppOffset - 1;
listing[1] := ch;
end;
j := dispHeight+ppOffset+1;
if (off = 0) or not smartTerminal then
outline(j,1,1,1); (* put out prompt or echo *)
i := off;
ch := exprEditor(j,1,1,2-off,i,off);
if smartTerminal then (* deboldify it *)
out1Line(j,1,maxchar);
for i := 1 to maxChar do ppBuf[i] := listing[i];
ppBufp := maxChar;
oppBufp := maxChar;
ppLine;
listing[1] := ppBuf[1]; (* fix things up for getToken *)
listing[maxChar+1] := ' ';
end;
procedure readline;
var i: integer;
procedure rdLine(var fi: atext);
var ch: ascii; i,j: integer;
begin
maxchar := 0;
curchar := 1;
if eofError or eof(fi) then
begin
if filedepth >= 1 then
begin (* continue with last file *)
filedepth := filedepth - 1;(* pop up a level *)
ppLine; (* give luser a sense of progress *)
readline; (* try again with popped file *)
end
else
begin (* yow - no file left - complain *)
pp20L('*** End of File enco',20); pp20L('untered while parsin',20);
pp10('g program ',10); ppLine;
eofError := true;
listing[1] := 'E'; (* force parser to give up *)
listing[2] := 'N';
listing[3] := 'D';
listing[4] := ';';
listing[5] := ' ';
maxchar := 5;
end
end
else
begin (* normal case - read in next line *)
if ord(fi↑) = 15B then get(fi); (* readln *)
while (ord(fi↑) = 15B) or (ord(fi↑) = 12B) or (ord(fi↑) = 0) do
begin
if ord(fi↑) = 15B then curFLine := curFLine + 1; (* count blank lines too *)
get(fi);
end;
if ord(fi↑) <> 14B then curFLine := curFLine + 1
else (* new page *)
begin
get(fi); (* skip past page mark (= ff) *)
curPage := curPage + 1;
ppInt(curpage); (* give luser a sense of progress *)
ppChar(' ');
ppOutNow;
curFLine := 1;
end;
if eoln(fi) then readln(fi);
while not eoln(fi) and (maxchar < 129) do
begin
maxchar := maxchar + 1;
read(fi,listing[maxchar]);
if ord(listing[maxchar]) = 11B then (* turn tabs into spaces *)
begin
i := 8*(((maxchar - 1) div 8) + 1);
for j := maxchar to i do listing[j] := ' ';
maxchar := i;
end;
end;
listing[maxchar+1] := ' '; (* always can count on a final blank *)
end;
end;
begin
case filedepth of
0: begin
if sParse then
begin
listing[1] := '*'; (* prompt for more input *)
readPPLine(0);
listing[1] := ' '; (* so getToken ignores prompt char *)
end
else
begin
pp20('End of File encounte',20); pp20('red while reading in',20);
pp10(' program. ',9); ppLine;
endOfLine := true;
maxChar := 0;
curchar := 1;
end
end;
1: rdline(file1);
2: rdline(file2);
3: rdline(file3);
4: rdline(file4);
5: rdline(file5);
end;
shownLine := false;
end;
(* aux function for motion clauses: thenCode *)
(* thenCode called by:
eadd6 - procedure add1Filler; (addStmnt)
Calls to:
appendEnd(1) makeNVar(1) makeNewVar(2) *)
function thenCode(evp: boolean; s: statementp): statementp;
var st: statementp; n: nodep; v: varidefp;
begin
if s↑.stype = signaltype then st := s (* treat signal specially *)
else
begin
st := newStatement;
with st↑ do (* make a cmon to execute the code *)
begin
stype := cmtype;
deferCm := false;
exprCm := false;
conclusion := s;
appendEnd(st,s);
n := newNode;
oncond := n;
end;
v := makeNVar(cmontype,nil); (* make a variable for the cmon *)
v↑.s := st;
st↑.cdef := v;
if evp then (* do we need to make an event variable? *)
begin
with n↑ do
begin
ntype := leafnode;
ltype := varitype;
vari := makeNVar(eventtype,nil);
makeNewVar(vari); (* if active block deal with environment entry *)
vid := nil;
end;
end;
makeNewVar(v); (* if active block deal with environment entry *)
end;
thenCode := st;
end;
(* waitParse *)
(* waitParse called by:
eadd2 - procedure addst2 (addStmnt)
Calls to:
checkArg(1) evalOrder(1) errprnt(1) exprParse(3)
XX *)
procedure waitParse(sp: statementp);
begin
with sp↑ do
begin
event := checkArg(exprParse,eventtype);
exprs := nil;
with event↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
pp20L(' Need an event varia',20); pp10('ble here ',8); errprnt;
relExpr(event);
event := nil;
end
else
if ntype <> leafnode then exprs := evalOrder(arg2,nil,true);
end;
end;
(* armMagicParse *)
(* armMagicParse called by:
eedit3 - procedure eEdit3; (editStmnt)
Calls to:
checkArg(1) getDelim(2) exprParse(3) errprnt(1) getToken(2)
getArgs(3) evalOrder(1)
*)
procedure armMagicParse(sp: statementp);
var n,lexpr: nodep; b: boolean;
begin
with sp↑ do
begin
cmdnum := checkArg(exprParse,svaltype);
getDelim(',');
dev := exprParse;
if dev = nil then b := true
else
with dev↑ do (* make sure it's a variable *)
begin
b := (ntype <> leafnode) or (ltype <> varitype);
if b then b := (ntype <> exprnode) or (op <> arefop);
end;
if b then
begin
pp20L(' Need a device varia',20); pp10('ble here ',8); errprnt;
bad := true; (* mark statement as bad *)
end
else
bad := false; (* statement is ok *)
getToken;
backup := true;
if (not endOfLine) or
(curToken.ttype <> delimtype) or (curToken.ch <> ';') then getDelim(',');
pnode↑.arg2 := nil;
getArgs(pnode); (* pretend we just saw a queryop *)
iargs := pnode↑.arg2; (* store away pointer to argument list *)
getToken;
backup := true;
if (not endOfLine) or
(curToken.ttype <> delimtype) or (curToken.ch <> ';') then getDelim(',');
pnode↑.arg2 := nil;
getArgs(pnode); (* do it all again for results list *)
oargs := pnode↑.arg2;
n := oargs;
b := false;
while (n <> nil) and not b do
begin (* make sure each entry in result list is a variable *)
with n↑.lval↑ do
begin
b := (ntype <> leafnode) or (ltype <> varitype);
if b then b := (ntype <> exprnode) or (op <> arefop);
end;
n := n↑.next;
end;
if b then
begin
pp20L(' Can only have varia',20); pp10('bles here ',9); errprnt;
bad := true; (* mark statement as bad *)
end;
if not bad then
begin (* set up exprs field *)
lexpr := evalOrder(cmdnum,nil,true);
if dev <> nil then (* evaluate device *)
if dev↑.ntype <> leafnode then
lexpr := evalOrder(dev↑.arg2,nil,true); (* push array subscripts *)
lexpr := evalOrder(iargs,lexpr,true); (* push input arguments *)
n := oargs;
while n <> nil do
with n↑ do
begin (* push any subscripts in result list *)
if lval↑.ntype = exprnode then lexpr := evalOrder(n↑.lval,lexpr,true);
n := next;
end;
exprs := lexpr;
end;
end;
end;
(* addStmnt: more aux routines: descend,elseTest,restoreCursor,setUpNewStmnt,viaOk *)
(* descend called by:
eadd3 - procedure addSetup; (addStmnt)
eadd5 - procedure add4Aux;
elseTest;
addNode;
Calls to:
pushStmnt (1)
elsetest called by:
eadd3 - procedure addSetup; (addStmnt)
eadd4 - procedure add1Aux;
eadd5 - procedure add4Aux;
Calls to:
descend(?) laststmnt(2b) pushNode(1a) pushStmnt(1a)
restoreCursor called by:
eadd3 - procedure addSetup; (addStmnt)
Calls to:
putStmnt(2)
setUpNewStmnt called by:
eadd2 - procedure addst2 (addStmnt)
eadd7 - procedure addDeclSt;
Calls to:
putStmnt(2)
viaOk called by:
eadd3 - procedure addSetup; (addStmnt)
Calls to: (none)
XX *)
procedure descend(st: statementp);
var sp: statementp;
begin
sp := nil;
with st↑ do
case stype of
fortype: sp := fbody;
whiletype: sp := body;
iftype: if els <> nil then sp := els else sp := thn;
cmtype: sp := conclusion;
otherwise begin end; (* nothing to do *)
end;
curLine := curline + 1; (* better than nothing(?) *)
if sp <> nil then
begin pushStmnt(sp,0); descend(sp) end; (* don't worry about cline *)
end;
function elseTest: boolean;
var i,j,l: integer; b: boolean; n: nodep;
begin
b := not emptyp; (* if pointing at empty stmnt then no ELSE possible *)
if b then
begin
l := cursorLine;
if sParse and (cursor <= sCursor) then
begin
cursor := sCursor;
curLine := 0;
descend(cursorStack[sCursor].st);
end
else lastStmnt(1,true); (* back up to previous statement *)
cursorLine := l;
with cursorStack[cursor], st↑ do
if (movetype <= stype) and (stype <= floattype) and (clauses <> nil) then
begin
n := clauses;
while n↑.next <> nil do n := n↑.next; (* find last clause *)
if n↑.ntype = cmonnode then
begin
curLine := cline;
pushNode(n); (* don't worry that .cline fields will be wrong *)
pushStmnt(n↑.cmon,2);
descend(n↑.cmon);
end;
end;
b := true;
i := cursor;
if sParse then j := sCursor else j := 1;
while (i >= j) and b do (* look for an IF with no ELSE *)
begin
with cursorStack[i] do
if stmntp then
if l < cline + st↑.nlines then i := 0 (* inside stmnt *)
else if st↑.stype = iftype then b := st↑.els <> nil;
if b then i := i - 1 else cursor := i;
end;
end;
elseTest := b;
end;
procedure restoreCursor;
begin
setCursor := true;
curLine := 0;
firstLine := 0;
lastLine := -1;
if not sParse then putStmnt(dprog,0,99) (* write & display new line *)
else
begin
cursor := sCursor - 1;
putStmnt(cursorStack[sCursor].st,0,99);
if cursor < sCursor then cursor := sCursor
end;
setCursor := false;
with cursorStack[cursor] do (* don't point at a proc def node *)
if (not stmntp) and (nd↑.ntype = procdefnode) then cursor := cursor - 1;
end;
procedure setUpNewStmnt(sp: statementp; ind: integer);
var b: boolean;
begin
setUp := true;
setCursor := false;
curLine := 1;
putStmnt(sp,ind,99); (* see how long we are *)
if sp↑.stype = declaretype then
b := sp↑.variables↑.tbits <> 2 (* don't advance cursor for procedure *)
else b := true;
if b then cursorline := cursorline + sp↑.nlines - 1;
setUp := false;
end;
procedure viaOk(i: integer; clOk: boolean; var viaCl: nodep);
var n: nodep;
begin
if clOk then
with cursorStack[cursor-i].st↑ do
if (stype = movetype) or (stype = jtmovetype) then
begin
n := clauses;
if i = 1 then
begin
if n <> nextLine.nd then
while n↑.next <> nextLine.nd do n := n↑.next;
end
else
if n <> nil then
while n↑.next <> nil do n := n↑.next;
if n <> nil then
if (n↑.ntype = viaptnode) or (n↑.ntype = byptnode) then viaCl := n;
end;
end;
(* edit: another aux routine: doAtCmd *)
(* XX doAtCmd called by:
emain3 - procedure eDoECmd; (edit)
Calls to:
evalOrder(1c) executeStmnt(3-edebug) freeNode(1) reFormatStmnt(3-epar3b)
XX *)
procedure doAtCmd;
var np: nodep; b: boolean; s: statementp;
begin
b := false;
with cursorStack[cursor] do (* check pointing at AFFIX statement *)
begin
if stmntp then b := st↑.stype = affixtype;
if b then
begin
np := newNode;
with np↑ do
begin
ntype := exprnode;
op := ttmulop;
arg1 := st↑.frame1;
arg2 := newNode;
arg3 := nil;
end;
with np↑.arg2↑ do
begin
ntype := exprnode;
op := tinvrtop;
arg1 := st↑.frame2;
arg2 := nil;
arg3 := nil;
end;
s := newStatement;
with s↑ do (* make up a new assignment stmnt *)
begin
stype := evaltype;
what := np;
exprs := evalOrder(np,nil,true); (* we want its current value *)
next := s; (* so dFreePdb doesn't flush us *)
last := s;
(* XX need to set 2nd parameter to executeStmnt below XX *)
executeStmnt(s,???); (* aval will be set by INTERP *)
relNode(np↑.arg2);
relNode(np);
np := aval;
aval↑.t↑.refcnt := 1; (* so it doesn't disappear *)
end;
relStatement(s); (* done with it now *)
with st↑ do
begin
if atexp <> nil then freeNode(atexp); (* release any old AT expr *)
atexp := np;
with frame1↑ do
if ntype = leafnode then np := nil
else np := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then np := evalOrder(arg2,np,true);
if byvar <> nil then
with byvar↑ do
if ntype <> leafnode then np := evalOrder(arg2,np,true);
exprs := evalOrder(atexp,np,true);
end;
reFormatStmnt(st,ind,cursorLine); (* may have changed nlines *)
end
else
begin pp20L('Must be pointing at ',20); pp20('an AFFIX statement ',18);
ppLine end;
end;
end;